module CamlinternalFormat = struct
type ('a, 'b) t =
  | Int of int
  | Int_fmt of string * int
  | Int_sfmt of string * int * string * int
  | Int_ssfmt of string * int * int * string * int
  | Int32 of int32
  | Int32_fmt of string * int32
  | Int32_sfmt of string * int * string * int32
  | Int32_ssfmt of string * int * int * string * int32
  | Int64 of int64
  | Int64_fmt of string * int64
  | Int64_sfmt of string * int * string * int64
  | Int64_ssfmt of string * int * int * string * int64
  | Intnat of nativeint
  | Intnat_fmt of string * nativeint
  | Intnat_sfmt of string * int * string * nativeint
  | Intnat_ssfmt of string * int * int * string * nativeint
  | Float of float
  | Float_fmt of string * float
  | Float_sfmt of string * int * string * float
  | Float_ssfmt of string * int * int * string * float
  | String_s of string
  | String_spad of bool * int * string
  | String_S of string
  | String_Spad of bool * int * string
  | Char_c of char
  | Char_C of char
  | Bool of bool
  | Alpha of ('a -> 'b)
  | Flush
;;

(***)

external format_int: string -> int -> string
  = "caml_format_int"
external format_int32: string -> int32 -> string
  = "caml_int32_format"
external format_int64: string -> int64 -> string
  = "caml_int64_format"
external format_nativeint: string -> nativeint -> string
  = "caml_nativeint_format"
external format_float: string -> float -> string
  = "caml_format_float"

(***)

let sformat =
  let b = Buffer.create 16 in
    fun l w r ->
      Buffer.add_string b l;
      Buffer.add_string b (string_of_int w);
      Buffer.add_string b r;
      Buffer.contents b
;;

let ssformat =
  let b = Buffer.create 16 in
    fun l w d r ->
      Buffer.add_string b l;
      Buffer.add_string b (string_of_int w);
      Buffer.add_char b '.';
      Buffer.add_string b (string_of_int d);
      Buffer.add_string b r;
      Buffer.contents b
;;

let channel_print oc x = match x with
  | Int n ->
      output_string oc (string_of_int n)
  | Int_fmt (fmt, n) ->
      output_string oc (format_int fmt n)
  | Int_sfmt (l, w, r, n) ->
      output_string oc (format_int (sformat l w r) n)
  | Int_ssfmt (l, w, d, r, n) ->
      output_string oc (format_int (ssformat l w d r) n)
  | Int32 n ->
      output_string oc (Int32.to_string n)
  | Int32_fmt (fmt, n) ->
      output_string oc (format_int32 fmt n)
  | Int32_sfmt (l, w, r, n) ->
      output_string oc (format_int32 (sformat l w r) n)
  | Int32_ssfmt (l, w, d, r, n) ->
      output_string oc (format_int32 (ssformat l w d r) n)
  | Int64 n ->
      output_string oc (Int64.to_string n)
  | Int64_fmt (fmt, n) ->
      output_string oc (format_int64 fmt n)
  | Int64_sfmt (l, w, r, n) ->
      output_string oc (format_int64 (sformat l w r) n)
  | Int64_ssfmt (l, w, d, r, n) ->
      output_string oc (format_int64 (ssformat l w d r) n)
  | Intnat n ->
      output_string oc (Nativeint.to_string n)
  | Intnat_fmt (fmt, n) ->
      output_string oc (format_nativeint fmt n)
  | Intnat_sfmt (l, w, r, n) ->
      output_string oc (format_nativeint (sformat l w r) n)
  | Intnat_ssfmt (l, w, d, r, n) ->
      output_string oc (format_nativeint (ssformat l w d r) n)
  | Float f ->
      output_string oc (string_of_float f)
  | Float_fmt (fmt, f) ->
      output_string oc (format_float fmt f)
  | Float_sfmt (l, w, r, f) ->
      output_string oc (format_float (sformat l w r) f)
  | Float_ssfmt (l, w, d, r, f) ->
      output_string oc (format_float (ssformat l w d r) f)
  | String_s s ->
      output_string oc s
  | String_spad (m, pad, s) ->
      if m then output_string oc s;
      for i = 1 to pad - String.length s do output_char oc ' ' done;
      if not m then output_string oc s;
  | String_S s ->
      output_char oc '"';
      output_string oc (String.escaped s);
      output_char oc '"';
  | String_Spad (m, pad, s) ->
      let p () =
	output_char oc '"';
	output_string oc (String.escaped s);
	output_char oc '"';
      in
	if m then p ();
	for i = 1 to pad - String.length s - 2 do output_char oc ' ' done;
	if not m then p ();
  | Char_c c ->
      output_char oc c
  | Char_C c ->
      output_char oc '\'';
      output_string oc (Char.escaped c);
      output_char oc '\'';
  | Bool true ->
      output_string oc "true"
  | Bool false ->
      output_string oc "false"
  | Alpha f ->
      f oc
  | Flush ->
      flush oc
;;

let buffer_print b x = match x with
  | Int n ->
      Buffer.add_string b (string_of_int n)
  | Int_fmt (fmt, n) ->
      Buffer.add_string b (format_int fmt n)
  | Int_sfmt (l, w, r, n) ->
      Buffer.add_string b (format_int (sformat l w r) n)
  | Int_ssfmt (l, w, d, r, n) ->
      Buffer.add_string b (format_int (ssformat l w d r) n)
  | Int32 n ->
      Buffer.add_string b (Int32.to_string n)
  | Int32_fmt (fmt, n) ->
      Buffer.add_string b (format_int32 fmt n)
  | Int32_sfmt (l, w, r, n) ->
      Buffer.add_string b (format_int32 (sformat l w r) n)
  | Int32_ssfmt (l, w, d, r, n) ->
      Buffer.add_string b (format_int32 (ssformat l w d r) n)
  | Int64 n ->
      Buffer.add_string b (Int64.to_string n)
  | Int64_fmt (fmt, n) ->
      Buffer.add_string b (format_int64 fmt n)
  | Int64_sfmt (l, w, r, n) ->
      Buffer.add_string b (format_int64 (sformat l w r) n)
  | Int64_ssfmt (l, w, d, r, n) ->
      Buffer.add_string b (format_int64 (ssformat l w d r) n)
  | Intnat n ->
      Buffer.add_string b (Nativeint.to_string n)
  | Intnat_fmt (fmt, n) ->
      Buffer.add_string b (format_nativeint fmt n)
  | Intnat_sfmt (l, w, r, n) ->
      Buffer.add_string b (format_nativeint (sformat l w r) n)
  | Intnat_ssfmt (l, w, d, r, n) ->
      Buffer.add_string b (format_nativeint (ssformat l w d r) n)
  | Float f ->
      Buffer.add_string b (string_of_float f)
  | Float_fmt (fmt, f) ->
      Buffer.add_string b (format_float fmt f)
  | Float_sfmt (l, w, r, f) ->
      Buffer.add_string b (format_float (sformat l w r) f)
  | Float_ssfmt (l, w, d, r, f) ->
      Buffer.add_string b (format_float (ssformat l w d r) f)
  | String_s s ->
      Buffer.add_string b s
  | String_spad (m, pad, s) ->
      if m then Buffer.add_string b s;
      for i = 1 to pad - String.length s do Buffer.add_char b ' ' done;
      if not m then Buffer.add_string b s;
  | String_S s ->
      Buffer.add_char b '"';
      Buffer.add_string b (String.escaped s);
      Buffer.add_char b '"';
  | String_Spad (m, pad, s) ->
      let p () =
	Buffer.add_char b '"';
	Buffer.add_string b (String.escaped s);
	Buffer.add_char b '"';
      in
	if m then p ();
	for i = 1 to pad - String.length s - 2 do Buffer.add_char b ' ' done;
	if not m then p ();
  | Char_c c ->
      Buffer.add_char b c
  | Char_C c ->
      Buffer.add_char b '\'';
      Buffer.add_string b (Char.escaped c);
      Buffer.add_char b '\'';
  | Bool true ->
      Buffer.add_string b "true"
  | Bool false ->
      Buffer.add_string b "false"
  | Alpha f ->
      Buffer.add_string b (f ())
  | Flush ->
      ()
;;
end

(***)

type 'a channel_format =
    ((out_channel, unit) CamlinternalFormat.t list -> unit) -> 'a
type 'a buffer_format =
    ((unit, string) CamlinternalFormat.t list -> unit) -> 'a
type 'a string_format =
    ((unit, string) CamlinternalFormat.t list -> string) -> 'a

let printf (fmt : 'a channel_format) : 'a =
  fmt (List.iter (CamlinternalFormat.channel_print stdout));;
let eprintf (fmt : 'a channel_format) : 'a =
  fmt (List.iter (CamlinternalFormat.channel_print stderr));;
let fprintf (oc : out_channel) (fmt : 'a channel_format) : 'a =
  fmt (List.iter (CamlinternalFormat.channel_print oc));;
let bprintf (b : Buffer.t) (fmt : 'a buffer_format) : 'a =
  fmt (List.iter (CamlinternalFormat.buffer_print b));;
let sprintf (fmt : 'a string_format) : 'a =
  fmt (fun l ->
	 let b = Buffer.create 16 in
	   List.iter (CamlinternalFormat.buffer_print b) l;
	   Buffer.contents b)
;;

type ('a, 'b) kchannel_format =
    ((out_channel, unit) CamlinternalFormat.t list -> 'a) -> 'b
type ('a, 'b) kbuffer_format =
    ((unit, string) CamlinternalFormat.t list -> 'a) -> 'b
type ('a, 'b) kstring_format =
    ((unit, string) CamlinternalFormat.t list -> 'a) -> 'b

let kfprintf (k : out_channel -> 'a) (oc : out_channel)
    (fmt : ('a, 'b) kchannel_format) : 'b =
  fmt (fun l -> List.iter (CamlinternalFormat.channel_print oc) l; k oc);;
let kbprintf (k : Buffer.t -> 'a) (b : Buffer.t)
    (fmt : ('a, 'b) kbuffer_format) : 'b =
  fmt (fun l -> List.iter (CamlinternalFormat.buffer_print b) l; k b);;
let ksprintf (k : string -> 'a) (fmt : ('a, 'b) kstring_format) : 'b =
  fmt (fun l ->
	 let b = Buffer.create 16 in
	   List.iter (CamlinternalFormat.buffer_print b) l;
	   k (Buffer.contents b))
;;
